home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byte0487.arc / TELLO.ARC / TRAVERSE.LSP < prev    next >
Encoding:
Text File  |  1980-01-01  |  3.3 KB  |  124 lines
  1. ; TRAVERSE
  2. ; Benchmark to create once and traverse a Structure
  3.  
  4. (defstruct node
  5.   (parents ())
  6.   (sons ())
  7.   (sn (snb))
  8.   (entry1 ())
  9.   (entry2 ())
  10.   (entry3 ())
  11.   (entry4 ())
  12.   (entry5 ())
  13.   (entry6 ())
  14.   (mark ()))
  15.  
  16. (defvar sn 0)
  17. (defvar rand 21.)
  18. (defvar count 0)
  19. (defvar marker nil)
  20. (defvar root)
  21.  
  22. (defun snb () (setq sn (1+ sn)))
  23.  
  24. (defun seed () (setq rand 21.))
  25.  
  26. (defun traverse-random () (setq rand (mod (* rand 17.) 251.)))
  27.  
  28. (defun traverse-remove (n q)
  29.        (cond ((eq (cdr (car q)) (car q))
  30.           (prog2 () (caar q) (rplaca q ())))
  31.          ((= n 0)
  32.           (prog2 () (caar q)
  33.              (do ((p (car q) (cdr p)))
  34.              ((eq (cdr p) (car q))
  35.               (rplaca q
  36.                   (rplacd p (cdr (car q))))))))
  37.          (t (do ((n n (1- n))
  38.              (q (car q) (cdr q))
  39.              (p (cdr (car q)) (cdr p)))
  40.             ((= n 0) (prog2 () (car q) (rplacd q p)))))))
  41.  
  42. (defun traverse-select (n q)
  43.        (do ((n n (1- n))
  44.         (q (car q) (cdr q)))
  45.        ((= n 0) (car q))))
  46.  
  47. (defun add (a q)
  48.        (cond ((null q)
  49.           `(,(let ((x `(,a)))
  50.               (rplacd x x) x)))
  51.          ((null (car q))
  52.           (let ((x `(,a)))
  53.            (rplacd x x)
  54.            (rplaca q x)))
  55.          (t (rplaca q
  56.             (rplacd (car q) `(,a .,(cdr (car q))))))))
  57.  
  58. (defun create-structure (n)
  59.        (let ((a `(,(make-node))))
  60.         (do ((m (1- n) (1- m))
  61.          (p a))
  62.         ((= m 0) (setq a `(,(rplacd p a)))
  63.              (do ((unused a)
  64.                   (used (add (traverse-remove 0 a) ()))
  65.                   (x) (y))
  66.                  ((null (car unused))
  67.                   (find-root (traverse-select 0 used) n))
  68.                  (setq x (traverse-remove (rem (traverse-random) n) unused))
  69.                  (setq y (traverse-select (rem (traverse-random) n) used))
  70.                  (add x used)
  71.                  (setf (node-sons y) `(,x .,(node-sons y)))
  72.                  (setf (node-parents x) `(,y .,(node-parents x))) ))
  73.         (push (make-node) a))))
  74.  
  75. (defun find-root (node n)
  76.  (do ((n n (1- n)))
  77.      ((= n 0) node)
  78.      (cond ((null (node-parents node))
  79.         (return node))
  80.        (t (setq node (car (node-parents node)))))))
  81.  
  82. (defun travers (node mark)
  83.        (cond ((eq (node-mark node) mark) ())
  84.          (t (setf (node-mark node) mark)
  85.         (setq count (1+ count))
  86.         (setf (node-entry1 node) (not (node-entry1 node)))
  87.         (setf (node-entry2 node) (not (node-entry2 node)))
  88.         (setf (node-entry3 node) (not (node-entry3 node)))
  89.         (setf (node-entry4 node) (not (node-entry4 node)))
  90.         (setf (node-entry5 node) (not (node-entry5 node)))
  91.         (setf (node-entry6 node) (not (node-entry6 node)))
  92.         (do ((sons (node-sons node) (cdr sons)))
  93.             ((null sons) ())
  94.             (travers (car sons) mark)))))
  95.  
  96. (defun traverse (root)
  97.        (let ((count 0))
  98.         (travers root (setq marker (not marker)))
  99.         count))
  100.  
  101. (qa-attempt "Traverse init" (setq root (create-structure 100.)) nil)
  102.  
  103. (qa-attempt "Traverse"
  104.    (do ((i 50. (1- i)))
  105.       ((= i 0))
  106.     (traverse root)
  107.     (traverse root)
  108.     (traverse root)
  109.     (traverse root)
  110.     (traverse root))
  111.   nil)
  112.  
  113. (define-timer traverse "Traverse, Traverse"
  114.   (do ((i 50. (1- i)))
  115.       ((= i 0))
  116.     (traverse root)
  117.     (traverse root)
  118.     (traverse root)
  119.     (traverse root)
  120.     (traverse root)))
  121.  
  122. (define-timer traverse-init "Traverse, Initialize"
  123.   (prog2 (setq root (create-structure 100.)) ()))
  124.